perm filename UTIL.OLD[PNT,HE] blob
sn#568496 filedate 1981-03-11 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00015 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 ENTRY
C00003 00003 ! callm: like call and calli
C00006 00004 ! formatting command: cvtab
C00008 00005 ! ttytype: type of the teletype
C00009 00006 ! esc_p,brk_n
C00010 00007 ! string comparison function
C00011 00008 ! dat_str
C00013 00009 ! ugetf, uget
C00015 00010 ! file manipulation
C00024 00011 ! monitor
C00026 00012 ! integer to 11 fp conversion
C00030 00013 ! date and time routines
C00031 00014 ! stack operations
C00040 00015 ! swap0,eswap
C00045 ENDMK
C⊗;
ENTRY;
BEGIN "UTILITY routines"
DEFINE $UTIL=TRUE;
REQUIRE "HEADER.SAI" SOURCE_FILE;
! EXTERNAL PROCEDURE PRESWAP;
! EXTERNAL PROCEDURE POSTSWAP;
! EXTERNAL PROCEDURE ERROR(STRING S,S1(NULL));
! EXTERNAL INTEGER _SKIP_; ! SAIL declaration ;
INTEGER ARRAY PAGNUM,LINNUM,SOSNUM[0:15]; ! keep track of page and line nums ;
! callm: like call and calli;
INTERNAL SIMPLE INTEGER PROCEDURE IOWD(INTEGER N,LOC);
RETURN(((-N)LAND '777777)LSH 18 +(LOC-1));
INTERNAL SIMPLE PROCEDURE CALLM(INTEGER OP,AC,ADDR);
BEGIN ! 1 2 3
012345678 9012 3 4567 890123456789012345
OP AC I X ADDR
'777 777 777777
This procedure acts like CALL or CALLI for UUO's that cannot be called
that way;
INTEGER CODE;
LABEL L;
CODE←(OP LSH 27)+(AC LSH 23) +ADDR;
MEMORY[LOCATION(L)]←CODE;
START_CODE;
L: 0 ; ! preceding code will put value here;
END;
END;
INTERNAL SIMPLE PROCEDURE CALLV0(STRING UUO; INTEGER AC,ADDR);
BEGIN INTEGER UUOCODE; LABEL L;
UUOCODE←CALL(CVSIX(UUO),"CALLIT");
IF UUOCODE=0 THEN PRINT("NO SUCH UUO: ",UUO);
MEMORY[LOCATION(L)]←UUOCODE + (ADDR LAND '777777)+(AC LSH 23);
START_CODE;
L: 0 ;
END;
END;
INTERNAL SIMPLE PROCEDURE CALLV(STRING UUO; INTEGER ADDR);
CALLV0(UUO,0,ADDR);
INTERNAL SIMPLE INTEGER PROCEDURE CALLU0(STRING UUO;INTEGER AC;
REFERENCE INTEGER ADDR);
BEGIN
INTEGER UUOCODE;
UUOCODE←CALL(CVSIX(UUO),"CALLIT");
IF UUOCODE=0 THEN PRINT("NO SUCH UUO: ",UUO)
ELSE RETURN(CODE(UUOCODE+(AC LSH 23),ADDR));
END;
INTERNAL SIMPLE INTEGER PROCEDURE CALLU(STRING UUO; REFERENCE INTEGER ADDR);
RETURN(CALLU0(UUO,0,ADDR));
INTERNAL SIMPLE PROCEDURE REASSI(INTEGER JOB; STRING DEVICE);
BEGIN
! assumes that DEVICE is inited by this job, and we want to assign to job
JOB: if it is to be assigned to the current job, set JOB←CALL(0,"PJOB").
To deassign, assign to nonexistent job ;
INTEGER DEV;
DEV←CVSIX(DEVICE);
START_CODE;
MOVE 1,JOB;
MOVE 2,DEV;
CALLI 1,'21; COMMENT THE REASSI UUO ;
END;
END;
! formatting command: cvtab;
INTERNAL SIMPLE STRING PROCEDURE CVTAB(STRING OLD_STRING);
BEGIN COMMENT convert tabs into relevant number of spaces to fill out;
INTEGER POSITION,LF_BREAK,TAB_BREAK,BRCHAR,BRCHAR2,I;
STRING NEW_STRING,TMP_STRING,TMP_STRING2;
NEW_STRING←NULL;
SETBREAK(LF_BREAK←GETBREAK,LF,NULL,"INA");
SETBREAK(TAB_BREAK←GETBREAK,TAB,NULL,"INS");
TMP_STRING←SCAN(OLD_STRING,LF_BREAK,BRCHAR);
DO BEGIN
IF TMP_STRING=CR THEN TMP_STRING←" "&CR;
! put a space for blank lines ;
TMP_STRING2←SCAN(TMP_STRING,TAB_BREAK,BRCHAR2);
WHILE BRCHAR2=TAB
DO BEGIN
I←8-(LENGTH(TMP_STRING2) MOD 8);
TMP_STRING2←TMP_STRING2&" "[1 TO I]
&SCAN(TMP_STRING,TAB_BREAK,BRCHAR2);
END;
NEW_STRING←NEW_STRING&TMP_STRING2;
TMP_STRING←SCAN(OLD_STRING,LF_BREAK,BRCHAR);
END UNTIL LENGTH(TMP_STRING)=0 AND BRCHAR=0;
RELBREAK(LF_BREAK);RELBREAK(TAB_BREAK);
RETURN(NEW_STRING);
END;
! ttytype: type of the teletype;
INTERNAL STRING PROCEDURE TTYTYPE;
BEGIN
INTEGER I;
I←-1;
CALLM('051,'6,LOCATION(I));
IF I=-1 THEN RETURN("DET");
I←I LSH -18;
IF I LAND '20000 THEN RETURN("DD")
ELSE IF I LAND '40000 THEN RETURN("DM")
ELSE IF I LAND '400000 THEN RETURN("III")
ELSE IF I LAND '200000 THEN RETURN("CTY")
ELSE RETURN("NEITHER III,DM,DD OR CTY; line characteristics are "&cvos(I)&",,000000");
END;
! esc_p,brk_n;
INTERNAL PROCEDURE ESC_P;
BEGIN
define ttyset = "'047000400121";
quick_code
hrroi 1,['004000000120]; comment [004000,,"P"];
ttyset 1, ; ! this last stuff does an esc-P;
end;
END;
INTERNAL PROCEDURE BRK_N;
BEGIN
define ttyset = "'047000400121";
quick_code
hrroi 1,['004000000516]; comment [004000,,400+"N"];
ttyset 1, ; ! this last stuff does an BRK-N;
end;
END;
! string comparison function ;
! compares two strings s1,s2. If they are equal returns 0
otherwise if s1 is alphabetically before s2 then
returns -1 else returns 1 ;
INTERNAL SIMPLE INTEGER PROCEDURE COMPEQU(STRING S1,S2);
BEGIN
INTEGER I1,I2;
IF EQU(S1,S2) THEN RETURN(0);
DO I1←LOP(S1) UNTIL I1≠(I2←LOP(S2));
IF I1>I2 THEN RETURN(-1) ELSE RETURN(1);
END;
! dat_str;
PRELOAD_WITH "Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sept","Oct","Nov","Dec";
STRING ARRAY $MONTH[0:11];
INTERNAL STRING PROCEDURE DAT_STR;
BEGIN
INTEGER SDATE,SSEC; integer width,digits;
INTEGER YEAR,MONTH,DATE,HOUR,MINUTE,SECOND;
STRING DATE_STRING;
comment using ACCTIM UUO;
quick_code;
calli '13,'400101;
hlrzm '13,SDATE;
hrrzm '13,SSEC;
end;
DATE←SDATE MOD 31;
SDATE←SDATE DIV 31;
MONTH←SDATE MOD 12;
YEAR←(SDATE DIV 12) + 1964;
SECOND←SSEC MOD 60;
SSEC←SSEC DIV 60;
MINUTE←SSEC MOD 60;
HOUR←SSEC DIV 60;
GETFORMAT(WIDTH,DIGITS);
SETFORMAT(0,0);
DATE_STRING←CVS(HOUR)&":";
SETFORMAT(-2,0);
DATE_STRING←DATE_STRING&CVS(MINUTE)&" ";
SETFORMAT(0,0);
DATE_STRING←DATE_STRING&CVS(DATE+1)&" "&$MONTH[MONTH]&" "&CVS(YEAR);
SETFORMAT(WIDTH,DIGITS);
RETURN(DATE_STRING);
END;
! ugetf, uget;
INTERNAL INTEGER PROCEDURE UGETF(INTEGER CHAN);
BEGIN ! positions the pointer to the last record in the file ;
define UGETF = '073000;
INTEGER I,CHN; LABEL DOUGTF;
CHN←CHAN;
quick_code;
move '13,CHN;
lsh '13,5;
addi '13,UGETF;
hrlm '13,DOUGTF; ! PREPARE UGETF;
DOUGTF:
I ;
end;
RETURN(I);
END;
INTERNAL INTEGER PROCEDURE UGET(INTEGER CHAN);
BEGIN ! gets the record number of the current place in the file ;
define MTAPE = '072000;
LABEL ADR,ADR1,DOMTPE; INTEGER CHN;
INTEGER GMOD; GMOD←CVSIX("GODMOD");
CHN←CHAN;
quick_code;
move '13,GMOD;
movem '13,ADR;
setzm '13,adr1;
move '13,CHN;
lsh '13,5;
addi '13,MTAPE;
hrlm '13,DOMTPE;
jrst DOMTPE ;
ADR:
0 ; ! '475744555744; ! SIXBIT /GODMOD/;
ADR1: 0 ;
DOMTPE:
ADR ;
move '13,ADR1;
movem '13,CHN;
end;
RETURN(CHN);
END;
! file manipulation;
INTERNAL INTEGER PROCEDURE FLINE(INTEGER CHAN);
RETURN(LINNUM[CHAN]+1);
INTERNAL INTEGER PROCEDURE FPAGE(INTEGER CHAN);
RETURN(PAGNUM[CHAN]+1);
INTERNAL STRING PROCEDURE FILENAME(INTEGER CHAN);
BEGIN ! given the i/o channel chan, this procedure returns full form of the
file name ;
STRING S,S1;
EXTERNAL INTEGER JOBJDA;
INTEGER DDB_ADDR;
INTEGER SPBREAK,I;
CALL(0,"SLEEP");
DDB_ADDR←MEMORY[LOCATION(JOBJDA)+CHAN] LAND '777777 ;
DEFINE DEVFIL='11,DEVEXT='12,FILPPN='14;
S←CVXSTR(CALL(DDB_ADDR+DEVFIL,"PEEK"))&"."&
CVXSTR(CALL(DDB_ADDR+DEVEXT,"PEEK"))[1 FOR 3]&
"["&CVXSTR(CALL(DDB_ADDR+FILPPN,"PEEK"))[1 TO 3]&","&
CVXSTR(CALL(DDB_ADDR+FILPPN,"PEEK"))[4 TO 6]&"]";
SETBREAK(SPBREAK←GETBREAK,NULL," ","I");
S1←SCAN(S,SPBREAK,I);
RELBREAK(SPBREAK);
RETURN(S1);
END;
INTERNAL PROCEDURE UDATEFILE(INTEGER CHAN);
BEGIN ! writes out the current file and reopens it
again at the end of the last page ;
INTEGER FLAG; INTEGER I; STRING S;
I←UGET(CHAN); CLOSE(CHAN);
S←FILENAME(CHAN);
LOOKUP(CHAN,S,FLAG);
ENTER(CHAN,S,FLAG);
USETI(CHAN,I); S←NULL;
DO S←S&INPUT(CHAN,0) UNTIL GETSTS(CHAN) LAND '20000;
! read til end of file;
USETO(CHAN,I); OUT(CHAN,S);
END;
INTERNAL INTEGER PROCEDURE OREADFILE(STRING FILE;REFERENCE INTEGER EOF;INTEGER MODE(0));
BEGIN
INTEGER CHAN,BRCHAR,FLAG;
OPEN(CHAN←GETCHAN,"DSK",MODE,19,0,1000,BRCHAR,EOF);
LOOKUP(CHAN,FILE,FLAG);
IF NOT FLAG THEN
BEGIN ! success ;
PAGNUM[CHAN]←LINNUM[CHAN]←SOSNUM[CHAN]←0;
SETPL(CHAN,LINNUM[CHAN],PAGNUM[CHAN],SOSNUM[CHAN]);
RETURN(CHAN); ! define counters to file on this channel ;
END;
RELEASE(CHAN);
CASE FLAG LAND '777777 OF
BEGIN
[0] ERROR(FILE&" is nonexistent");
[1] ERROR(FILE&" has illegal PPN");
[2] ERROR(FILE&" protection violation");
[3] ERROR(FILE&" is busy");
ELSE ERROR(FILE&": unknown error in opening file")
END;
END;
INTERNAL STRING PROCEDURE READFILE(STRING FILE; INTEGER MODE(0));
BEGIN
INTEGER CHAN,EOF,FFBREAK;
STRING MSSGE;
CHAN←OREADFILE(FILE,EOF,MODE);
SETBREAK(FFBREAK←GETBREAK,FF,NULL,"ISN");
MSSGE←NULL;
WHILE NOT EOF DO MSSGE←MSSGE&" "&INPUT(CHAN,FFBREAK);
RELEASE(CHAN);
RELBREAK(FFBREAK);
RETURN(MSSGE);
END;
INTERNAL INTEGER PROCEDURE OWRITEFILE(STRING FILE; INTEGER MODE(0));
BEGIN ! this will destroy existing file ;
INTEGER CHAN,BRCHAR,EOF,FLAG;
OPEN(CHAN←GETCHAN,"DSK",MODE,0,19,1000,BRCHAR,EOF);
ENTER(CHAN,FILE,FLAG);
IF FLAG THEN
BEGIN
RELEASE(CHAN);
CASE FLAG LAND '777777 OF
BEGIN
[0] ERROR("NULL filename given");
[1] ERROR(FILE&": illegal PPN");
[2] ERROR(FILE&" protection violation");
[3] ERROR(FILE&" is currently busy");
['12] ERROR("DISK is full...groan...");
ELSE ERROR(FILE&": unknown file error, code ="&
CVOS(FLAG LAND '777777))
END;
END;
RETURN(CHAN);
END;
INTERNAL PROCEDURE WRITEFILE(STRING FILE,MSSGE);
BEGIN ! this will destroy existing file ;
INTEGER CHAN;
CHAN←OWRITEFILE(FILE);
OUT(CHAN,MSSGE);
CLOSE(CHAN);
RELEASE(CHAN);
END;
INTERNAL PROCEDURE DELFILE(STRING FILE);
BEGIN
INTEGER CHAN,BRCHAR,EOF,FLAG;
OPEN(CHAN←GETCHAN,"DSK",0,0,19,1000,BRCHAR,EOF);
ENTER(CHAN,FILE,FLAG);
RENAME(CHAN,NULL,0,FLAG);
CLOSE(CHAN);
RELEASE(CHAN);
END;
INTERNAL BOOLEAN PROCEDURE FILE_ABSENT(STRING FNAME);
BEGIN "check if FNAME exists"
INTEGER INPCH,BRCHR,EOF;
BOOLEAN E;
OPEN(INPCH←GETCHAN,"DSK",0,3,0,1000,BRCHR,EOF);
LOOKUP(INPCH,FNAME,EOF);
E←(EOF = '777777000000) OR (EOF='777777000001);
RELEASE(INPCH);
RETURN(E);
END;
INTERNAL INTEGER PROCEDURE ORAFILE(STRING FILE,S(NULL);BOOLEAN ERROR_RETURN(TRUE));
BEGIN
INTEGER CHAN,BRCHAR,EOF,FLAG;
IF FILE_ABSENT(FILE) THEN
BEGIN
CHAN←OWRITEFILE(FILE);
CLOSE(CHAN);
RELEASE(CHAN);
IF S=FF THEN S←S[2 TO ∞]; ! if begins with formfeed then can lop it off;
END;
! writes out the string s into file FILE:
if the first character is a formfeed then start on a new page.;
OPEN(CHAN←GETCHAN,"DSK",0,19,19,1000,BRCHAR,EOF);
LOOKUP(CHAN,FILE,FLAG);
ENTER(CHAN,FILE,FLAG);
IF FLAG THEN
BEGIN STRING S;
RELEASE(CHAN);
CASE FLAG LAND '777777 OF
BEGIN
[0] S←FILE&" is nonexistent";
[1] S←FILE&" illegal PPN";
[2] S←FILE&" protection violation";
[3] S←FILE&" is busy";
['12] S←"DISK is full.. groan..";
ELSE S←FILE&" error code = "&CVOS(FLAG LAND '777777)
END;
IF ERROR_RETURN THEN ERROR(S);
PRINT(S,CRLF);
RETURN(-1);
END;
IF S=FF THEN UGETF(CHAN)
ELSE BEGIN
INTEGER I; STRING S1;
DO INPUT(CHAN,0) UNTIL EOF;
I←UGET(CHAN);
USETI(CHAN,I);
S1←NULL;
DO S1←S1&INPUT(CHAN,0) UNTIL EOF;
USETO(CHAN,I);
OUT(CHAN,S1);
END;
OUT(CHAN,S);
RETURN(CHAN);
END;
INTERNAL PROCEDURE CRAFILE(INTEGER CHAN);
BEGIN
CLOSE(CHAN);
RELEASE(CHAN);
END;
INTERNAL PROCEDURE ADDFILE(STRING FILE,S);
BEGIN ! adds string S to a file FILE, which if does not exist is created
and then updates the file;
INTEGER CHAN;
CHAN←ORAFILE(FILE,S);
CRAFILE(CHAN);
END;
! monitor;
INTERNAL SIMPLE INTEGER PROCEDURE LOGIN(STRING PPN(NULL));
BEGIN
STRING S;
external integer _skip_;
INTEGER PTYLINE;
DO ptyline←ptyget UNTIL _skip_;
IF PPN≠NULL THEN S←PPN ELSE
BEGIN
STRING S1,S2;
S1←CVXSTR(CALL(0,"DSKPPN"))[1 TO 3];
S2←CVXSTR(CALL(0,"DSKPPN"))[4 TO 6];
WHILE S1=" " DO S1←S1[2 TO ∞];
WHILE S2=" " DO S2←S2[2 TO ∞];
S←S1&"."&S2;
END;
ptostr(PTYLINE,"L "&S&CRLF);
S←PTYSTR(PTYLINE,"↑");
S←PTYSTR(PTYLINE,".");
RETURN(PTYLINE);
END;
PROCEDURE MONCOM(INTEGER PTYLINE; STRING COMMAND);
BEGIN
STRING S;
PTOSTR(PTYLINE,COMMAND&CRLF);
S←PTYSTR(PTYLINE,"↑");
S←PTYSTR(PTYLINE,".");
END;
INTERNAL PROCEDURE LOGOUT(INTEGER PTYLINE);
PTYREL(PTYLINE);
INTERNAL PROCEDURE MONITOR(STRING COMMAND,PPN(NULL));
BEGIN
INTEGER PTY;
PTY←LOGIN(PPN);
MONCOM(PTY,COMMAND);
LOGOUT(PTY);
END;
! integer to 11 fp conversion ;
! PROCEDURE FOR CONVERTING A FLOATING POINT NUMBER IN 11 FORMAT ;
! plagiarized from BES in move.sai;
INTERNAL PROCEDURE FLTOUT(REAL FNUM; REFERENCE INTEGER XNUM1,XNUM2);
BEGIN
LABEL ST1,ST2,OVER,FLTEND;
INTEGER BYTE,NUM1,NUM2;
BYTE←'013200000002;
START_CODE
MOVE 2,FNUM;
JUMPGE 2,ST1;
MOVN 2,2;
TLO 2,'400000;
ST1: JFCL 2,ST2;
ST2: ADDI 2,4;
JFCL 2,OVER;
DPB 2,BYTE;
SETZ 1,;
LSHC 1,16;
MOVEM 1,NUM1;
SETZ 1,;
LSHC 1,16;
MOVEM 1,NUM2;
END;
XNUM1←NUM1;
XNUM2←NUM2;
GOTO FLTEND;
OVER: OUTSTR("ERROR-ROUNDING OVERFLOW"&CRLF);
FLTEND: END;
ifc false thenc
INTERNAL REAL PROCEDURE RFVAL(INTEGER WORD1,WORD2);
BEGIN
! This procedure gives the real floating point value of a floating point number
in WORD1 and WORD2 with F format of pdp-11.;
REAL X;
INTEGER SIGN,EXPONENT,FRACTION;
! PRINT(CRLF,"WORD1=",CVOS(WORD1)," WORD2=",CVOS(WORD2));
SIGN← WORD1 LSH -15;
EXPONENT← (WORD1 LSH 21) LSH -28 ;
FRACTION← (((WORD1 LAND '177) LOR (IF EXPONENT THEN '200 ELSE 0)) LSH 16) LOR WORD2 ;
IF SIGN=1 THEN BEGIN EXPONENT← LNOT EXPONENT; FRACTION← '100000000 - FRACTION; END;
! PRINT(CRLF,"SIGN=",SIGN," EXPONENT=",CVOS(EXPONENT)," FRACTION=",CVOS(FRACTION));
MEMORY[LOCATION(X),INTEGER]← SIGN LSH 35 LOR EXPONENT LSH 27 LOR FRACTION LSH 3 ;
! PRINT(CRLF,CVOS(X));
RETURN(X);
END;
endc
INTERNAL REAL PROCEDURE RFVAL0(INTEGER I);
BEGIN
INTEGER SIGNEXPONENT,FRACTION,NEWNUM; REAL X;
IF I=0 THEN RETURN(0.0);
SIGNEXPONENT←I LAND '777000000000;
FRACTION← ((I LAND '777777760) LSH -1)+'400000000;
NEWNUM←SIGNEXPONENT+FRACTION;
IF NEWNUM<0 THEN NEWNUM←((LNOT NEWNUM) + 1) LOR '400000000000;
MEMORY[LOCATION(X),INTEGER]←NEWNUM;
RETURN(X);
END;
INTERNAL REAL PROCEDURE RFVAL(INTEGER WORD1,WORD2);
RETURN(RFVAL0((WORD1 LSH 20)+(WORD2 LSH 4)));
! date and time routines;
! total runtime since login in msecs;
INTERNAL SIMPLE INTEGER PROCEDURE RUNTIM;
RETURN(CALL(0,"RUNTIM"));
! number of days since Jan 1, 1964;
INTERNAL SIMPLE INTEGER PROCEDURE DAYCNT;
RETURN(CALL(0,"DAYCNT"));
! number of msecs after midnight;
INTERNAL SIMPLE INTEGER PROCEDURE MSTIME;
RETURN(CALL(0,"MSTIME"));
! stack operations;
COMMENT range of stack is 1 to LIMIT, and the first element in the stack is at 1.
TOP represents the current top, and LIMIT the maximum;
DEFINE NEW_STACK(STACKTYPE,ELEMENTTYPE) "[][]" =
[ BEGIN
RPTR(STACKTYPE) PTR;
ELEMENTTYPE ARRAY ARR[1:SIZE];
PTR←NEW_RECORD(STACKTYPE);
STACKTYPE:LIMIT[PTR]←SIZE;
STACKTYPE:TOP[PTR]←0;
MEMORY[LOCATION(STACKTYPE:STACK[PTR])]↔MEMORY[LOCATION(ARR)];
RETURN(PTR);
END;];
DEFINE POP(STACKTYPE,DEF)"[][]"=[
BEGIN INTEGER TOP;
IF (TOP←STACKTYPE:TOP[PTR])=0
THEN BEGIN
PRINT("UNDERFLOW IN STACKTYPE STACK: RETURNING DEFAULT");
RETURN(DEF);
END;
STACKTYPE:TOP[PTR]←TOP -1;
RETURN(STACKTYPE:STACK[PTR][TOP]);
END];
DEFINE PUSH(STACKTYPE,ELEMENT,ELEMENTTYPE)"[][]"=[
BEGIN
INTEGER TOP,NLIMIT;
IF (TOP←STACKTYPE:TOP[PTR])=STACKTYPE:LIMIT[PTR]
THEN BEGIN "increase size of stack"
ELEMENTTYPE ARRAY ARR[1:NLIMIT←TOP*1.25+10];
! arrtran doesnot work with pointers because there is problem with GC
ARRTRAN(ARR,STACKTYPE:STACK[PTR]);
INTEGER I;
FOR I←1 STEP 1 UNTIL TOP DO
ARR[I]←STACKTYPE:STACK[PTR][I];
STACKTYPE:LIMIT[PTR]←NLIMIT;
MEMORY[LOCATION(STACKTYPE:STACK[PTR])]↔MEMORY[LOCATION(ARR)];
! ARRCLR(ARR);
END;
STACKTYPE:TOP[PTR]←(TOP←TOP+1);
STACKTYPE:STACK[PTR][TOP]←ELEMENT;
END];
DEFINE TRIM(STACKTYPE,ELEMENTTYPE)"[][]"=[
IF STACKTYPE:TOP[PTR]≠STACKTYPE:LIMIT[PTR] THEN
BEGIN
INTEGER TOP;
ELEMENTTYPE ARRAY ARR[1:TOP←STACKTYPE:TOP[PTR]];
! arrblt will give GC problems with rptr arrays
ARRBLT(ARR[1],STACKTYPE:STACK[PTR][1],TOP);
INTEGER I;
FOR I←1 STEP 1 UNTIL TOP DO ARR[I]←STACKTYPE:STACK[PTR][I];
MEMORY[LOCATION(STACKTYPE:STACK[PTR])]↔MEMORY[LOCATION(ARR)];
! ARRCLR(ARR);
STACKTYPE:LIMIT[PTR]←TOP;
END;];
DEFINE JOIN(P1,P2,ELEMENTYPE,NEWSTACKROUTINE,STACKTYPE)"[][]"=[
BEGIN
INTEGER I;
RPTR(STACKTYPE)P3;
INTEGER TOP1,TOP2,TOP3,LIMIT;
TOP1←STACKTYPE:TOP[P1];
TOP2←STACKTYPE:TOP[P2];
P3←NEWSTACKROUTINE(TOP3←(TOP1+TOP2)*1.25+10);
! ARRBLT(STACKTYPE:STACK[P3][1],STACKTYPE:STACK[P1][1],TOP1);
! ARRBLT(STACKTYPE:STACK[P3][TOP1+1],STACKTYPE:STACK[P2][1],TOP2);
FOR I←1 STEP 1 UNTIL TOP1 DO
STACKTYPE:STACK[P3][I]←STACKTYPE:STACK[P1][I];
FOR I←1 STEP 1 UNTIL TOP2 DO
STACKTYPE:STACK[P3][TOP1+I]←STACKTYPE:STACK[P2][I];
STACKTYPE:TOP[P3]←TOP1+TOP2;
RETURN(P3);
END;];
DEFINE ATTACH(P1,P2,ELEMENTYPE,STACKTYPE)"[][]"=[
BEGIN
RPTR(STACKTYPE)P3;
INTEGER TOP1,TOP2,TOP3,LIMIT;
INTEGER I;
TOP1←STACKTYPE:TOP[P1];
TOP2←STACKTYPE:TOP[P2];
TOP3←TOP1+TOP2;
IF STACKTYPE:LIMIT[P1]<TOP3
THEN BEGIN
ELEMENTYPE ARRAY ARR[1:STACKTYPE:LIMIT[P1]←TOP3*1.25+10];
! ARRBLT(ARR[1],STACKTYPE:STACK[P1][1],TOP1);
FOR I←1 STEP 1 UNTIL TOP1 DO
ARR[I]←STACKTYPE:STACK[P1][I];
MEMORY[LOCATION(ARR)]↔MEMORY[LOCATION(STACKTYPE:STACK[P1])];
END;
! ARRBLT(STACKTYPE:STACK[P3][TOP1+1],STACKTYPE:STACK[P2][1],TOP2);
FOR I←1 STEP 1 UNTIL TOP2 DO
STACKTYPE:STACK[P3][TOP1+I]←STACKTYPE:STACK[P2][I];
STACKTYPE:TOP[P1]←TOP3;
END;];
REQUIRE "[][]" DELIMITERS;
INTERNAL RPTR(ISTACK)PROCEDURE NEW_ISTACK(INTEGER SIZE(10));
NEW_STACK(ISTACK,INTEGER);
INTERNAL RPTR(FSTACK)PROCEDURE NEW_FSTACK(INTEGER SIZE(10));
NEW_STACK(FSTACK,REAL);
INTERNAL RPTR(RSTACK)PROCEDURE NEW_RSTACK(INTEGER SIZE(10));
NEW_STACK(RSTACK,[RECORD_POINTER(ANY_CLASS)]);
INTERNAL INTEGER PROCEDURE IPOP(RPTR(ISTACK)PTR);
POP(ISTACK,0);
INTERNAL REAL PROCEDURE FPOP(RPTR(FSTACK)PTR);
POP(FSTACK,0.0);
INTERNAL RPTR(ANY_CLASS) PROCEDURE RPOP(RPTR(RSTACK)PTR);
POP(RSTACK,NULL_RECORD);
INTERNAL PROCEDURE ISPUSH(RPTR(ISTACK)PTR; INTEGER ELEMENT);
PUSH(ISTACK,ELEMENT,INTEGER);
INTERNAL PROCEDURE FSPUSH(RPTR(FSTACK)PTR; REAL ELEMENT);
PUSH(FSTACK,ELEMENT,REAL);
INTERNAL PROCEDURE RPUSH(RPTR(RSTACK)PTR; RPTR(ANY_CLASS)ELEMENT);
PUSH(RSTACK,ELEMENT,[RPTR(ANY_CLASS)]);
INTERNAL RPTR(ISTACK)PROCEDURE IJOIN(RPTR(ISTACK)P1,P2);
JOIN(P1,P2,INTEGER,NEW_ISTACK,ISTACK);
INTERNAL RPTR(FSTACK)PROCEDURE FJOIN(RPTR(FSTACK)P1,P2);
JOIN(P1,P2,REAL,NEW_FSTACK,FSTACK);
INTERNAL RPTR(RSTACK)PROCEDURE RJOIN(RPTR(RSTACK)P1,P2);
JOIN(P1,P2,[RPTR(ANY_CLASS)],NEW_RSTACK,RSTACK);
INTERNAL PROCEDURE IATTACH(RPTR(ISTACK)P1,P2);
ATTACH(P1,P2,INTEGER,ISTACK);
INTERNAL PROCEDURE FATTACH(RPTR(FSTACK)P1,P2);
ATTACH(P1,P2,REAL,FSTACK);
INTERNAL PROCEDURE RATTACH(RPTR(RSTACK)P1,P2);
ATTACH(P1,P2,[RPTR(ANY_CLASS)],RSTACK);
INTERNAL PROCEDURE ITRIM(RPTR(ISTACK)PTR);
TRIM(ISTACK,INTEGER);
INTERNAL PROCEDURE FTRIM(RPTR(FSTACK)PTR);
TRIM(FSTACK,REAL);
INTERNAL PROCEDURE RTRIM(RPTR(RSTACK)PTR);
TRIM(RSTACK,[RPTR(ANY_CLASS)]);
INTERNAL PROCEDURE ZERO_ISTACK(RPTR(ISTACK)PTR);
ISTACK:TOP[PTR]←0;
INTERNAL PROCEDURE ZERO_FSTACK(RPTR(FSTACK)PTR);
FSTACK:TOP[PTR]←0;
INTERNAL PROCEDURE ZERO_RSTACK(RPTR(RSTACK)PTR);
RSTACK:TOP[PTR]←0;
INTERNAL INTEGER PROCEDURE ISIZE(RPTR(ISTACK)PTR);
RETURN(ISTACK:TOP[PTR]);
INTERNAL INTEGER PROCEDURE FSIZE(RPTR(FSTACK)PTR);
RETURN(FSTACK:TOP[PTR]);
INTERNAL INTEGER PROCEDURE RSIZE(RPTR(RSTACK)PTR);
RETURN(RSTACK:TOP[PTR]);
! swap0,eswap;
INTERNAL BOOLEAN PROCEDURE SWAP0(INTEGER ARRAY SAVADR,GETADR,ACCUM);
BEGIN
! integer array SAVADR[0:4],GETADR[0:5],ACCUM[0:'17],
ACCUM['17]←SAVADR[0],,GETADR[0]
accums are the values with which accumulators are to be
set up before swapping to the new core image ;
! this procedure will save the current state of the POINTY program in
the file specified by SAVADR, and swap to the core image specified by GETADR.
If the right half of SWAPWORD is zero, then the core image will continue
running. ;
EXTERNAL INTEGER JOBSA;
INTEGER ARRAY ACS[0:15]; ! temporary storage for accumulators;
INTEGER EA0,EA15;
INTEGER AACS0,AACS15,AACS14; ! address of ACS[0],ACS[15],ACS[14];
LABEL RESUME;
BOOLEAN SAMECOREIMAGE;
AACS0←LOCATION(ACS[0]);
AACS15←LOCATION(ACS[15]);
AACS14←LOCATION(ACS[14]);
JOBSA←LOCATION(RESUME);
EA0←LOCATION(ACCUM[0]);
SAMECOREIMAGE←FALSE;
PRESWAP;
quick_code
MOVEM 15,@AACS15; COMMENT SAVE ACCUMS ;
MOVE 15,AACS0;
BLT 15,@AACS14;
MOVS 15,EA0; ! set up accumulator values preceding call;
BLT 15,15; ! set up accumulator calls;
CALLI 15,'400004; ! swap to new program;
SETOM 1,SAMECOREIMAGE;! didnt swap ;
RESUME: JFCL ; ! no-op;
JFCL ; ! restore accumulators;
MOVS 15,AACS0; ! get address of AC[0];
BLT 15,15; ! BLT into memory;
end;
POSTSWAP(SAMECOREIMAGE);
RETURN(SAMECOREIMAGE);
END;
! swap to E, then resume ;
PROCEDURE ESWAP(REFERENCE STRING MODIFY_STRING);
BEGIN
! this procedure will save the current state of the POINTY program in
the file XXXXXX.DMP[PNT,HE], and swap to E to a file called E$TEMP.TMP[PNT,HE]
which it writes with the contents of MODIFY_STRING,
and allows the user to modify. When the user exits E
by doing <control>XRUN, the POINTY program resumes by swapping back
XXXXXX.DMP[PNT,HE] and renaming it POINTY, and then reading in E$TEMP.TMP[PNT,HE]
as the input string MODIFY_STRING;
INTEGER ARRAY EARRAY[0:'17];
INTEGER ARRAY SAVADR[0:4],GETADR[0:5];
STRING COREIMAGEFILE,E$TEMP;
E$TEMP←"E$TEMP.TMP[PNT,HE]";
WRITEFILE(E$TEMP,MODIFY_STRING);
COREIMAGEFILE←"XXXXXX.DMP";
SAVADR[0]←CVSIX("DSK");
SAVADR[1]←CVFIL(COREIMAGEFILE,SAVADR[2],SAVADR[4]);
GETADR[0]←CVSIX("SYS");
GETADR[1]←CVFIL("E.DMP[1,3]",GETADR[2],GETADR[4]);
GETADR[3]←1;
GETADR[5]←CALL(0,"DSKPPN"); ! use current dsk ppn;
ARRCLR(EARRAY);
EARRAY[0]←CVFIL(COREIMAGEFILE,EARRAY[1],EARRAY[3]);
EARRAY[6]←CVSIX("DSK");
EARRAY['14]←CVFIL(E$TEMP,EARRAY['13],EARRAY['11]);
EARRAY['12]←CVSIX("DSK");
EARRAY['13]←EARRAY['13] LOR '100000; ! /N mode ;
EARRAY['15]←1; ! line no = 1;
EARRAY['16]←1; ! page no = 1;
EARRAY['17]←(LOCATION(SAVADR[0]) LSH 18) LOR LOCATION(GETADR[0]);
BRK_N;
PRINT("I am swapping to the Editor; when you are done with the Editor, type
<control>XRUN to resume. If you get out of E by typing <control>E, get
back into E by typing CONT and resume by typing <control>XRUN.
If you lose your core image, you can resume by doing a RU "&COREIMAGEFILE&"
");
SWAP0(SAVADR,GETADR,EARRAY);
DELFILE(COREIMAGEFILE);
MODIFY_STRING←READFILE(E$TEMP);
DELFILE(E$TEMP);
END;
END;
END "UTILITY routines";